home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 21 / Cream of the Crop 21 (Terry Blount) (October 1996).iso / os2 / freetype.zip / debugger.pas < prev    next >
Pascal/Delphi Source File  |  1996-08-19  |  4KB  |  190 lines
  1. program Debugger;
  2.  
  3. uses Drivers, Objects, Views, Menus, App, MsgBox, TTIns, CodeTv, StackTv,
  4.      Crt, TTTypes, TTError, TTTables, TTFile, TTDebug;
  5.  
  6. {$I DEBUGGER.INC}
  7.  
  8. type
  9.   TMyApp = object( TApplication )
  10.              constructor Init;
  11.              procedure NewWindow; virtual;
  12.              procedure InitMenuBar; virtual;
  13.              procedure HandleEvent( var Event : TEvent ); virtual;
  14.            end;
  15.  
  16. var
  17.   CW : PCodeWindow;
  18.   SW : PStackWindow;
  19.  
  20.   Code_Range : array[1..3] of PCodeRange;
  21.  
  22. procedure Initialize;
  23. var
  24.   i : int;
  25. begin
  26.   for i := 1 to 3 do Code_Range[i] := Get_CodeRange(1);
  27. end;
  28.  
  29. procedure TMyApp.NewWindow;
  30. var
  31.   R  : TRect;
  32.   RR : TRangeRec;
  33. begin
  34.   Desktop^.GetExtent(R);
  35.   R.B.X := 32;
  36.  
  37.   New( CW, Init( R ) );
  38.   Desktop^.Insert(CW);
  39.  
  40.   Generate_Range( Code_Range[1], RR );
  41.   CW^.CodeView^.Set_Range( RR );
  42.  
  43.   Desktop^.GetExtent(R);
  44.   R.A.X := 32;
  45.   R.B.X := 48;
  46.   New( SW, Init( R, Stack, StackSize ) );
  47.  
  48.   Desktop^.Insert(SW);
  49. end;
  50.  
  51.  
  52. procedure TMyApp.InitMenuBar;
  53. var
  54.   R : TRect;
  55. begin
  56.   GetExtent(R);
  57.   R.B.Y := R.A.Y + 1;
  58.   MenuBar := New( PMenuBar, Init( R, NewMenu(
  59.                   NewSubMenu('~F~ichier', hcNoContext, NewMenu(
  60.                            NewItem('~O~uvrir','F3', kbF3, cmFileOpen,hcNoCOntext,
  61.                            nil )),
  62.                   nil )
  63.                 )));
  64. end;
  65.  
  66.  
  67. procedure TMyApp.HandleEvent( var Event : TEvent );
  68. begin
  69.  
  70.   inherited HandleEvent(Event);
  71.  
  72.   case Event.What of
  73.  
  74.     evCommand : case Event.Command of
  75.  
  76.                   cmNewWin : NewWindow;
  77.  
  78.                 else
  79.                   exit;
  80.                 end;
  81.  
  82.   else
  83.     exit;
  84.   end;
  85.  
  86.   ClearEvent(Event);
  87. end;
  88.  
  89.  
  90. constructor TMyApp.Init;
  91. begin
  92.   inherited Init;
  93.   NewWindow;
  94. end;
  95.  
  96. var
  97.   MyApp : TMyApp;
  98.  
  99.   Range       : Int;
  100.   P           : PByteArray;
  101.   FileName    : String;
  102.   Font_Buffer : PStorage;
  103.   Out_File    : Text;
  104.   T, I        : int;
  105.  
  106.  
  107. begin
  108.  
  109.   GetMem( Font_Buffer, 64000 );
  110.  
  111.   InitBuffer( Font_Buffer^, 64000 );
  112.  
  113.   for i:=0 to ParamCount do Writeln(ParamStr(i));
  114.  
  115.   If paramCount<>1 then
  116.    begin
  117.     Writeln('Usage : ',paramStr(0),' FontName[.TTF]');
  118.     Halt(1);
  119.    end;
  120.  
  121.   Filename := ParamStr(1);
  122.   if Pos('.',FileName)=0 then FileName:=FileName+'.TTF';
  123.   if not Open_TrueType_File( Filename ) then
  124.    begin
  125.     Writeln('Erreur, le fichier ',ParamStr(1),' n''a pu être ouvert');
  126.     Halt(1);
  127.    end;
  128.  
  129.   Load_TrueType_Tables;
  130.  
  131.   if not Load_TrueType_MaxProfile then
  132.    begin
  133.     Writeln('Erreur, la table ''maxp'' est introuvable');
  134.     Halt(1);
  135.    end;
  136.  
  137.   if not Load_TrueType_CVT then
  138.    begin
  139.     Writeln('Erreur, la table ''cvt '' est introuvable');
  140.     Halt(1);
  141.    end;
  142.  
  143.   if not Load_TrueType_Header then
  144.    begin
  145.     Writeln('Erreur, l''en-tête est introuvable');
  146.     Halt(1);
  147.    end;
  148.  
  149.   SetScale( 14, 96, Font_Header^.UnitsPerEM );
  150.  
  151.   if not Init_Interpreter( MaxProfile ) then
  152.     begin
  153.       Writeln('Erreur, initialisation interpréteur');
  154.       Halt(1);
  155.     end;
  156.  
  157.   T := LookUp_TrueType_Table('fpgm');
  158.  
  159.   if T < 0 then
  160.     begin
  161.       Writeln('FONT table not found');
  162.       halt(1);
  163.     end;
  164.  
  165.   Assign( Out_File,'' );
  166.   Rewrite( Out_File );
  167.  
  168.   Writeln( Out_File,'Font Program Offset :', Table_Dir_Entries^[T].Offset );
  169.   Writeln( Out_File,'Font Program Size   :', Table_Dir_Entries^[T].Length );
  170.  
  171.   CodeSize := Table_Dir_Entries^[T].Length;
  172.  
  173.   P := Alloc_CodeRange( Codesize, Range );
  174.   if P = nil then
  175.    begin
  176.      writeln('Erreur, impossible d''allouer le font program' );
  177.      halt(1);
  178.    end;
  179.  
  180.   writeln( Out_File,'------- FONT -------');
  181.   Read_At_Font_File( Table_Dir_Entries^[T].Offset,
  182.                      P^, CodeSize );
  183.  
  184.   Initialize;
  185.  
  186.   MyApp.Init;
  187.   MyApp.Run;
  188.   MyApp.Done;
  189. end.
  190.